Aminet 33/Aminet 33 - October 1999.iso/Aminet/misc/math/TCalcStats2c.lha/TCalcStats2c/AREXX/Covariance.rexx

OS/2 REXX Batch file | 1998-08-02 | 7.1 KB | 341 lines

/* Covariance Statistics */

options results
if ~show('P','TCALC') then do
    address command 'run turbocalc:turbocalc'
    address command 'waitforport TCALC'
    loadflag=1
end
address 'TCALC'
'DEFPUBSCREEN()'
/* Add-in Rexx Math Library needed for some routines */
signal on syntax
if ~show('l','rexxmathlib.library') then
   call addlib('rexxmathlib.library',0,-30)
if ~show('l','rexxreqtools.library') then
   call addlib('rexxreqtools.library',0,-30)
if ~show('l','rexxsupport.library') then
   call addlib('rexxsupport.library',0,-30)
  /* add to library list */
signal off syntax

/* Start Main Routine */
if loadflag=1 then 'Load()'
'ActivateWindow()'
range=rtgetstring(,"Enter Cell Range for Input","Input Request") /*,,'rt_pubscrname="TCALC"')*/
colon=pos(":",range)
if colon=0 then do
    'Message "Please select a range before executing this script"'
    'DEFPUBSCREEN("Workbench")'
    exit
end

/* Find cell references and cell, column numbers */
start_cell=substr(range,1,colon-1)
end_cell=substr(range,colon+1)
start_row=cellrow(start_cell)
end_row=cellrow(end_cell)
start_col=cellcol(start_cell)
end_col=cellcol(end_cell)
NRows=end_row-start_row+1
NCols=end_col-start_col+1

/* Get cell reference for output range */
out_cell=rtgetstring(,"Enter Cell Reference for Output","Input Request") /*,,'rt_pubscrname="TCALC"')*/
if out_cell="" then do
    'DEFPUBSCREEN("Workbench")'
    exit
end
if length(out_cell)<2 | datatype(left(out_cell,1),'n')=1 then do
    'Message "Invalid cell reference"'
    'DEFPUBSCREEN("Workbench")'
    exit
end


/* Suppress Screen Redraw to Speed Things Up */
'Refresh 0'

/* Open a small output window on tcalc screen*/
fo=0
CR='0a'x
DisplayMsg="Calculating...Please Wait."||CR||"User input is disabled during calculation."||CR
if open(6Info, 'con:100/0/450/80/Progress/SCREEN TCALC', w) then do
     call writeln(6Info, DisplayMsg)
    fo=1
end
else do
    'Message "TCALC Screen not available for Progress messages"'
end
CALL DELAY(150)

/* Get cell references for top cell in each column */
'SelectCell' start_cell
do col=start_col to end_col
    'GetCursorPos'
    top_cell.col=result
    'Column 1'
end

/* Get labels for later use on output */
'SelectCell' start_cell
'GetValue'
testlabel=result
testlabel=strip(testlabel)
if datatype(testlabel,'n')=1 then do
    labelflag=0
    do x=1 to NCols
    title.x="Column "||x
    end
end
else do
    labelflag=1
    NRows=NRows-1
    do x=1 to NCols
    'GetValue'
    str=result
    title.x=translate(strip(str),"_"," ")
    'Column 1'
    end
end
if fo then call writech(6Info,"Progress...10 ")

/* Get data from cell range */
col=start_col
lav=0
tot=0
count.=0
total.=0
do x=1 to NCols
    'SelectCell' top_cell.col
    if labelflag=1 then 'CursorDown 1'
    do y=1 to NRows
        'GetValue'
        valtest=result
        if datatype(valtest)='NUM' then do
            'GetValue'
            val=result
            data.x.y=val
            tot=tot+val
            total.x=tot
            count.x=1+count.x
        end
        'CursorDown 1'
    end
    col=col+1
    tot=0
    lav=0
    val=0
end
if fo then call writech(6Info,"20 ")

/* Calculate Column Squares and Products */
SQ.=0
PR.=0
TSQ.=0
TPR.=0
do x=1 to NCols
    do y=1 to NRows
        SQ.x=(data.x.y)**2
        TSQ.x=(TSQ.x)+(SQ.x)
    end
end
if fo then call writech(6Info,"40 ")
do x=1 to NCols
    do z=1 to NCols
        do y=1 to NRows
            PR.x.z=(data.x.y)*(data.z.y)
            TPR.x.z=(TPR.x.z)+(PR.x.z)
        end
    end
end
N=count.1
if fo then call writech(6Info,"60 ")

/* Calculate Means */
mean.=0
do x=1 to NCols
    mean.x=(total.x)/(count.x)
end
if fo then call writech(6Info,"80 ")

/* Calculate Correlation */
top.=0
bot.=0
cov.=0
do x =1 to NCols
    do z=1 to NCols
        cov.x.z=((TPR.x.z)/N)-(mean.x)*(mean.z)
    end
end
if fo then do
    call writeln(6Info,"100 ")
    call writeln(6Info,"Writing output to window...")
end

/* Output */
'SelectCell' out_cell
'ColumnWidth 10'
'Put "Covariance: UnGrouped Data"'
'CursorDown 2'
'Column 1'
do x=1 to NCols
    'GetCursorPos'
    first_cell.x=result
    title=""""||title.x||""""
    'Alignment 2'
    'Put' title
    'Column 1'
end
'SelectCell' first_cell.1
'Column -1'
'CursorDown 1'
do x=1 to NCols
    title=""""||title.x||""""
    'Put' title
    'CursorDown 1'
end
d=0
b=0
do x=1 to NCols
'SelectCell' first_cell.x
'CursorDown 1'
    do z=1 to NCols
        'Put' format(cov.x.z,,4)
        'CursorDown 1'
    end
end
'Refresh 1'
'Refresh 2'
/*'Message' "Finished"*/
/*indicate the main script is finished*/
DisplayMsg="Cleaning up ...."||CR||"Exiting"
result=writeln(6Info, DisplayMsg)
if result~=0 then do
    /*Wait 3 seconds*/
    CALL DELAY(150)
    /* close window*/
    result=close(6Info)
end
'DEFPUBSCREEN("Workbench")'
exit

/* Procedures */

cellrow: procedure
do
    parse arg cell
    do charpos=2 to length(cell)
    if datatype(substr(cell,charpos,1),n) then return substr(cell,charpos)
    end
    return 0
end
Return

cellcol: procedure
do
    parse arg cell
    labels="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    cell=upper(cell)
    len=length(cell)
    val=0
do charpos=1 to len
    if datatype(substr(cell,charpos,1),n) then
    do cell=reverse(substr(cell,1,charpos-1))
    do x=1 to length(cell)
    val=(26**(x-1))*pos(substr(cell,x,1),labels)+val
    end
    return val
    end
    end
    return 0
end
Return
/* It is important to put the exposed array at the end of the next line */
Sort: procedure expose NCols NRows data.
do x=1 to NCols
L=(xtoy(2,int(log(NRows-1)/log(2))))-1
    Do Until L<1
    L=trunc(int(L/2))
    Do J=1 to L
            Do K=J+L To NRows-1 By L
            I=K
            dumdat=data.x.I
            Do while I>L
                y=I-L
                If data.x.y ~> dumdat then Leave
                data.x.I=data.x.y
                I=I-L
            End
            data.x.I=dumdat
            End
        End
    End
End
Return

syntax:
     if arg(1)='FAIL' then do
        'Message "Library is unavailable."'
        'DEFPUBSCREEN("Workbench")'
        exit
        end
    'DEFPUBSCREEN("Workbench")'
    exit

Format:  procedure

     arg number, before, after
     CallLine = SIGL
     if ~datatype(CallLine, 'N') then CallLine = '??'

     /* Make sure we have a number as first (required) argument    */
     if ~datatype(number, 'N') then do
        if number = '' then
           fc = 17     /* Wrong number of arguments           */
        else
           fc = 47     /* Arithmetic conversion error             */
        signal FormatSyntaxError
     end
     num = number + 0
     if before = '' & after = '' then
        return num
     else do
        parse var num integer '.' fraction
        if before = '' then before = length(integer)
        if after = '' then after = length(fraction)
        if ~datatype(before, N) | ~datatype(after, N) then
           do fc = 18
           signal FormatSyntaxError
       end
        if before < length(integer) then do
           fc = 18
           signal FormatSyntaxError
        end
        if after ~= length(fraction) then do
           fraction = trunc(('.'fraction'0') + ('.'copies('0', after)'5'), after)
        if integer<1&integer>-1 then integer=integer
           else integer = integer + (fraction % 1)
           fraction = substr(fraction, 3)
        end
        if fraction >= 0 then
           return right(integer, before)'.'fraction
        else
           return right(integer, before)
     end

 FormatSyntaxError:
        if show('F', STDERR) then
           call writeln(STDERR, '+++ Error' fc 'in line' CallLine':' errortext(fc))
        else
           mess='+++ Error' fc 'in line' CallLine':' errortext(fc)
        'Message' mess
        parse source Func .
        if Func = 'FUNCTION' then do
        'DEFPUBSCREEN("Workbench")'
           exit "Err"
        end
        else do
        'DEFPUBSCREEN("Workbench")'
           exit 10
        end